home *** CD-ROM | disk | FTP | other *** search
/ Amiga Tools 2 / Amiga Tools 2.iso / tools / jade / lisp / isearch.jl < prev    next >
Lisp/Scheme  |  1995-03-09  |  9KB  |  283 lines
  1. ;;;; isearch.jl -- Emacs style incremental search
  2. ;;;  Copyright (C) 1994 John Harper <jsh@ukc.ac.uk>
  3.  
  4. ;;; This file is part of Jade.
  5.  
  6. ;;; Jade is free software; you can redistribute it and/or modify it
  7. ;;; under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 2, or (at your option)
  9. ;;; any later version.
  10.  
  11. ;;; Jade is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;;; GNU General Public License for more details.
  15.  
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with Jade; see the file COPYING.  If not, write to
  18. ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. (provide 'isearch)
  21.  
  22. ;;; Bugs:
  23. ;;; Doesn't un-wrap itself when backtracking
  24.  
  25. (defvar case-fold-search t
  26.   "Buffer-local variable, when non-nil case of characters is ignored when
  27. searching.")
  28. (make-variable-buffer-local 'case-fold-search)
  29.  
  30. (defvar isearch-last-match nil
  31.   "The last regexp successfully (i.e. entered with RET) found by isearch.")
  32.  
  33.  
  34. ;;; Wrappers for some regexp functions to trap errors
  35.  
  36. (defun isearch-find-next-regexp (pos)
  37.   (setq isearch-re-error nil)
  38.   (error-protect
  39.       (find-next-regexp (car (car isearch-trace)) pos nil case-fold-search)
  40.     (regexp-error
  41.       (setq isearch-re-error t)
  42.       'regexp-error)))
  43.  
  44. (defun isearch-find-prev-regexp (pos)
  45.   (setq isearch-re-error nil)
  46.   (error-protect
  47.       (find-prev-regexp (car (car isearch-trace)) pos nil case-fold-search)
  48.     (regexp-error
  49.       (setq isearch-re-error t)
  50.       'regexp-error)))
  51.  
  52. (defun isearch-looking-at ()
  53.   (setq isearch-re-error nil)
  54.   (error-protect
  55.       (looking-at (car (car isearch-trace)) nil nil case-fold-search)
  56.     (regexp-error
  57.       (setq isearch-re-error t)
  58.       'regexp-error)))
  59.  
  60.  
  61. ;;; I-search stack handling. The variable `isearch-trace' holds a stack of
  62. ;;; all strings and match positions in the current search. It looks
  63. ;;; something like,
  64. ;;;   ((SEARCH-REGEXP [MATCH-POS]... )... )
  65. ;;; But although the current string will be on the stack, the current match
  66. ;;; position won't -- the cursor position is used to show this.
  67.  
  68. ;; Pops the top match and moves the cursor to it.
  69. (defun isearch-pop-match ()
  70.   (let
  71.       ((item (car isearch-trace)))
  72.     (if (cdr item)
  73.     (progn
  74.       (goto-char (nth 1 item))
  75.       (rplaca isearch-trace (cons (car item) (nthcdr 2 item))))
  76.       (goto-char isearch-initial-pos)))
  77.   (setq isearch-failing nil))
  78.  
  79. ;; Pops the top string, then moves to the top match of the next string.
  80. (defun isearch-pop-string ()
  81.   (when (cdr isearch-trace)
  82.     (setq isearch-trace (cdr isearch-trace))
  83.     (isearch-pop-match)))
  84.  
  85. ;; Pushes a match at POS onto the top string
  86. (defun isearch-push-match (pos)
  87.   (let
  88.       ((item (car isearch-trace)))
  89.     (rplaca isearch-trace (cons (car item) (cons pos (cdr item))))))
  90.  
  91. ;; Pushes the current position, pushes the STRING onto the top of the
  92. ;; stack, then searches for it
  93. (defun isearch-push-string (string)
  94.   (isearch-push-match (cursor-pos))
  95.   (setq isearch-trace (cons (cons string nil) isearch-trace))
  96.   (unless (isearch-looking-at)
  97.     (let
  98.     ((next (if isearch-forwards
  99.            (isearch-find-next-regexp (next-char))
  100.          (isearch-find-prev-regexp (prev-char)))))
  101.       (cond
  102.     ((posp next)
  103.       (goto-char next)
  104.       (setq isearch-failing nil))
  105.     ((null next)
  106.       (setq isearch-failing t)
  107.       (beep))))))
  108.  
  109.  
  110. ;; Keymap
  111.  
  112. (defvar isearch-keymap (make-keylist))
  113. (bind-keys isearch-keymap
  114.   "Ctrl-s"    'isearch-next-forward
  115.   "Ctrl-r"    'isearch-next-backward
  116.   "Ctrl-g"    'isearch-cancel
  117.   "Ctrl-q"    '(progn (setq next-keymap-path nil) (isearch-title))
  118.   "Ctrl-w"    'isearch-yank-word
  119.   "Ctrl-y"    'isearch-yank-line
  120.   "RET"        'isearch-accept
  121.   "ESC"        'isearch-accept
  122.   "BS"        'isearch-rubout)
  123.  
  124.  
  125. ;; Display the status message, has to be done after each command
  126. (defun isearch-title ()
  127.   (let
  128.       ((msg (concat (if isearch-failing "failing ")
  129.             (if isearch-wrapped "wrapped ")
  130.             "I-search: "
  131.             (car (car isearch-trace))
  132.             (if isearch-re-error "    *Invalid/incomplete regexp*"))))
  133.     (aset msg 0 (char-upcase (aref msg 0)))
  134.     (message msg)))
  135.  
  136. ;; Accept our current position
  137. (defun isearch-accept ()
  138.   (interactive)
  139.   (set-mark auto-mark isearch-initial-pos isearch-buffer)
  140.   (message "Set auto-mark.")
  141.   (setq isearch-last-match (car (car isearch-trace)))
  142.   (throw 'isearch (cursor-pos)))
  143.  
  144. ;; Cancel the search or if search is failing backtrack to the last match
  145. (defun isearch-cancel ()
  146.   (interactive)
  147.   (if (not (isearch-looking-at))
  148.       (progn
  149.     (while (and (not (isearch-looking-at)) (cdr isearch-trace))
  150.       (isearch-rubout))
  151.     (isearch-title))
  152.     (goto-char isearch-initial-pos)
  153.     (throw 'isearch nil)))
  154.  
  155. ;; Copy the rest of the current word to the search string
  156. (defun isearch-yank-word ()
  157.   (interactive)
  158.   (when (isearch-looking-at)
  159.     (isearch-push-string (concat (car (car isearch-trace))
  160.                  (copy-area (match-end)
  161.                         (forward-word 1 (match-end))))))
  162.   (isearch-title))
  163.  
  164. ;; Copy the rest of the line to the search string
  165. (defun isearch-yank-line ()
  166.   (interactive)
  167.   (when (isearch-looking-at)
  168.     (isearch-push-string (concat (car (car isearch-trace))
  169.                  (copy-area (match-end) (line-end)))))
  170.   (isearch-title))
  171.  
  172. ;; Backup one match/string
  173. (defun isearch-rubout ()
  174.   (interactive)
  175.   (cond
  176.     ((cdr (car isearch-trace))
  177.       (isearch-pop-match))
  178.     ((cdr isearch-trace)
  179.       (isearch-pop-string))
  180.     (t
  181.       (error "Beginning of I-search")))
  182.   (isearch-title))
  183.  
  184. ;; Add the typed character to the search string
  185. (defun isearch-unbound-key-fun ()
  186.   (let
  187.       ((str (current-event-string)))
  188.     (if (/= (length str) 1)
  189.         (isearch-accept)
  190.       (isearch-push-string (concat (car (car isearch-trace)) str))))
  191.   (isearch-title))
  192.  
  193. (defun isearch (isearch-forwards)
  194.   (let
  195.       ((isearch-trace (cons (cons "" nil) nil))
  196.        (isearch-initial-pos (cursor-pos))
  197.        (isearch-buffer (current-buffer))
  198.        isearch-failing
  199.        isearch-wrapped
  200.        isearch-re-error
  201.        (esc-means-meta nil)        ; want to bind to ESC
  202.        (old-kp keymap-path))
  203.     (setq keymap-path '(isearch-keymap))
  204.     (add-hook 'unbound-key-hook 'isearch-unbound-key-fun)
  205.     (unwind-protect
  206.     (catch 'isearch
  207.       (isearch-title)
  208.       (recursive-edit))
  209.       (with-buffer isearch-buffer
  210.     (remove-hook 'unbound-key-hook 'isearch-unbound-key-fun)
  211.     (setq keymap-path old-kp)))))
  212.  
  213. ;;;###autoload
  214. (defun isearch-forward ()
  215.   "Enters the incremental search mode. You are then able to type letters to add
  216. to the regexp being searched for. Special commands are,\n
  217.   `Ctrl-s'     Search forwards for another occurrence
  218.   `Ctrl-r'     Search backwards 
  219.   `Ctrl-g'     If the search is failing, backtrack to the first non-failing
  220.                match, else, cancel the search leaving the cursor at its
  221.                original position.
  222.   `Ctrl-w'     Copy the rest of the current word into the search string
  223.   `Ctrl-y'     Copy the rest of the line to the search string
  224.   `RET'        Exit isearch leaving the cursor at its current position
  225.   `BS'         Retrace your movements one step"
  226.   (interactive)
  227.   (isearch t))
  228.  
  229. ;;;###autoload
  230. (defun isearch-backward ()
  231.   "Similar to `isearch-forward' except the first searching is done in the other
  232. direction."
  233.   (interactive)
  234.   (isearch nil))
  235.  
  236. (defun isearch-next-forward ()
  237.   (interactive)
  238.   (if (and (equal (car (car isearch-trace)) "") isearch-last-match)
  239.       (progn
  240.     (isearch-push-string isearch-last-match)
  241.     (isearch-title))
  242.     (let
  243.     ((next (if (and isearch-failing isearch-forwards)
  244.                (progn
  245.              (setq isearch-wrapped t)
  246.              (buffer-start))
  247.          (next-char))))
  248.       (setq next (isearch-find-next-regexp next))
  249.       (cond
  250.         ((posp next)
  251.       (isearch-push-match (cursor-pos))
  252.       (setq isearch-failing nil)
  253.       (goto-char next))
  254.     ((null next)
  255.       (setq isearch-failing t)
  256.       (beep)))
  257.       (setq isearch-forwards t)
  258.       (isearch-title))))
  259.  
  260. (defun isearch-next-backward ()
  261.   (interactive)
  262.   (if (and (equal (car (car isearch-trace)) "") isearch-last-match)
  263.       (progn
  264.     (isearch-push-string isearch-last-match)
  265.     (isearch-title))
  266.     (let
  267.     ((next (if (and isearch-failing (not isearch-forwards))
  268.            (progn
  269.              (setq isearch-wrapped t)
  270.              (buffer-end))
  271.          (prev-char))))
  272.       (setq next (isearch-find-prev-regexp next))
  273.       (cond
  274.        ((posp next)
  275.     (isearch-push-match (cursor-pos))
  276.     (setq isearch-failing nil)
  277.     (goto-char next))
  278.        ((null next)
  279.     (setq isearch-failing t)
  280.     (beep)))
  281.       (setq isearch-forwards nil)
  282.       (isearch-title))))
  283.